home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Tools⁄Additions / MacScheme20 / Compatibility / compat.sch next >
Encoding:
Text File  |  1989-04-25  |  2.3 KB  |  82 lines  |  [TEXT/EDIT]
  1. ; Compatibility file for the Abelson and Sussman textbook.
  2.  
  3. ; sequence is synonymous with begin
  4.  
  5. (macro sequence
  6.        (lambda (l)
  7.          `(begin ,@(cdr l))))
  8.  
  9. ; old-fashioned I/O procedure names
  10.  
  11. (define (print x . p)
  12.   (if p (set! p (car p)) (set! p (current-output-port)))
  13.   (newline)
  14.   (write x p))
  15.  
  16. (define princ display)
  17.  
  18. ; explode, implode (isn't this code ugly?)
  19.  
  20. (define (explode symbol)
  21.   (map (lambda (x) (string->symbol (list->string (list x))))
  22.        (string->list (symbol->string symbol))))
  23.  
  24. (define (implode char-list)
  25.   (string->symbol
  26.    (list->string (map (lambda (x)
  27.                         (car (string->list
  28.                               (symbol->string x))))
  29.                       char-list))))
  30.  
  31. ; property lists
  32.  
  33. (define (put var property value)
  34.   (if (null? var) (set! var 'nil))
  35.   (if (not (symbol? var))
  36.       (error "Non-symbol argument to put" var))
  37.   (if (eq? property 'pname)
  38.       (error "The pname property is inviolate" var))
  39.   (let ((entry (assq property (cdr (->pair var)))))
  40.     (if entry
  41.         (set-cdr! entry value)
  42.         (set-cdr! (->pair var)
  43.                   (cons (cons property value)
  44.                         (cdr (->pair var)))))
  45.     value))
  46.  
  47. (define (get var property)
  48.   (if (null? var) (set! var 'nil))
  49.   (if (not (symbol? var))
  50.       (error "Non-symbol argument to get" var))
  51.   (let ((entry (assq property (cdr (->pair var)))))
  52.     (if entry (cdr entry) #!false)))
  53.  
  54. ; Environments should be abstract objects but aren't.
  55. ; For example, you can take the car of some
  56. ; environments, which doesn't make any sense.
  57.  
  58. (define user-initial-environment '())
  59.  
  60. ; WARNING:  make-environment works reliably only in code that is compiled
  61. ; at optimization level 0.
  62.  
  63. (macro make-environment
  64.        (lambda (l)
  65.          `((lambda ()
  66.              ,@(cdr l)
  67.              (cdr (->pair (lambda () 0)))))))     ; yuck
  68.  
  69. ; exception handler to make the car and cdr of the empty list be
  70. ; the empty list.  The query system relies on this.
  71.  
  72. (let ((old-handler (vector-ref **error-code-table** 14)))
  73.   (vector-set!
  74.    **error-code-table**
  75.    14
  76.    (lambda (errcode bytecode machine-state)
  77.      (if (null? (car (vector-ref machine-state 0)))
  78.          (begin (set-car! (vector-ref machine-state 0) '(()))
  79.                 (restart-machine-state machine-state))
  80.          (old-handler errcode bytecode machine-state))))
  81.   #!true)
  82.